BMUG Revelations/BMUG Revelations.toast/Programming/Programming Languages/Yerk 3.64/System source/Files

Text File | 1993-06-17 | 14KB | 488 lines

\ Files  - file object and loader
\ 09/10/84  CBD Version 1.0
\ 10/12/84  CBD Added loader,  Length: -> bytesRead:
\ 12/14/84  cbd nested loads, no default:
\  7/04/86  cdn Added HFS references
\  7/13/86  cdn Moved in SFPReply
\  8/15/86  rfd Skip HFS search is vRefNum supplied
\  8/26/86  cdn Added classinit for File
\  9/8/86   rfd added dirfind resfind etc. to speed up open
\ 12/3/87    rfl fixed pileup of pathnames in hopen
\ 12/3/87   rfl addef flushvol:
\  9/5/88    rfl    fixed hfs?
\ 12/14/88    rfl fixing data record for hfs
\  5/23/90    rfl added event processing during file loading
\  7/25/90    rfl fixed load so that ?pause works during +echo
\  9/27/90    rfl    savesig now finds app signature
\ 11/12/90    rfl recoded volname?
\ 12/14/90    rfl added font change to //
\ 12/29/90    rfl    mods for path now sarray object
\  1/31/91    rfl    fixed saveSig to get signature, not file name; font stuff now
\                here; no longer need chicago 9.
\  1/26/92    rfl    fixed Savesig to use heap file object. remove: loadfile closed the file.
\                This wasn't good if the file was the standalone application.
\ 11/25/92    rfl    Changed Last: to look at file size instead of using $ ffffff.
\ 12/11/92    rfl    pulled ftype out of file, now global; added put: for single character write
\                removed antiquated words like sony, external, profile; added where:
\  4/30/93    rfl    Now when saving a snapshot of the environment, you no longer
\                have to worry about closing the windows. The open windows are first marked
\                closed, the file is saved, then they are all marked open again
\  5/10/93    rfl    shortened filinit
\  5/12/93    rfl    Hopen: and orf now lock down strings because of occasional problems
\                 not building search path correctly due to moving of data
\  5/17/93    rfl    removed res string call from clear: filelist so yerk.rsrc not
\               necessary for string
\  6/04/93    rfl    modified for source documentation; sfind and screate moved from 'mod'
\  6/17/93    rfl    srcCreate now replaces a filemark with no yerk words defined after it.

Decimal

\ ( n fcb(abs) -- )
Create dirfind
    popA0
    popD0
    $ A260 w,
    pushD0
    next,

: volname? { strobj -- b }
    start: strobj next: strobj
    IF ascii : <> ELSE false THEN ;

0 -> quitvec    \ leave vectors in a clean state
0 -> abortvec

: (nevent1) decho IF ?pause THEN ;
'c (nevent1) vect nEvent        \ use as stub until Event is loaded

: -echo  false -> decho ;
: +echo  true  -> decho ;
: -curs  false -> curs  ;
: +curs  true  -> curs  ;

\ ( -- T or F ) returns true if on HFS
: hfs? $ 3f6 -base w@ 0> ;

0 value path    \ is instantiated by getPtxt

\  Strip volume name & HFS paths from a file name
: MFSname { addr len -- addr' len' }
    len ++> addr
    len 0
    DO    -1 ++> addr                \ scan through string backwards
        addr c@ ascii : =        \ first colon we see, we stop
        IF 1 ++> addr i -> len leave THEN
    LOOP
    addr len
;

: UpCase true -> ucase ;
: LoCase false ->  ucase ;

\ ( addr len -- pfa len t OR f )  find word for name on stack. map to uppercase
\   by default, but if ucase is false, then leave text alone.
: sfind here >str255 ucase
    IF 1+ here c@ >uc here ELSE -base THEN latest (find) ;

\ ( addr len -- )  create a new dict name/link for name on stack
: sCreate docs IF line# w, THEN        \ for source documentation
    sfind IF here count type type# 184 ( is redefined ) cr 2drop THEN
    createHdr -4 allot ;

\ don't allow two adjacent words to be file marks...this will
\ prevent a load file from being embedded in the dictionary...unless the
\ loadfile begins by defining yerk words...thus a loadfile cannot do any
\ defining for this to work all the time.
: srcCreate ( addr len -- )            \ create a filemark entry to dictionary
    docs
    IF dup 31 > ?error 187
        latest name> @ fileMk =        \ is the last word a filemark?
        IF latest dup >line -> dp pfa lfa @ current ! THEN    \ yes, so get rid of it
        LoCase
        screate
        fileMk ,
        UpCase
    ELSE 2drop
    THEN ;

    4 Ordered-Col    fTypes        \ list of filetypes used by all files for stdget:

:CLASS File  <Super Object

    134 Bytes        FCB            \ max MAC parameter block(108 but for hgetvinfo)
    \ Standard File data
    Int                Good        \ this is like a variable record
    Var                fType
    Int                vRefNum
    Int                Version
    64 Bytes        Filename    \ max size is 64

    :M  CLOSE:  ^base (close)  ;M

    \ ( addr len -- )  assigns file name to fcb
    :M  NAME:  ^base !fName  ;M

    \ ( dirid -- )  set the DirID for the fcb
    :M  SETDIRID: ^base 48 + !  ;M

    \ ( -- dirid )  get the DirID for the fcb
    :M  GETDIRID: ^base 48 + @  ;M

    \ ( vref# -- )  set the volRefNum for the fcb
    :M  SETVREF:  ^base 22 + w! ;M

    \ ( -- vref# )  get the volRefNum for the fcb
    :M  GETVREF:  ^base 22 + w@ ;M

    \ ( mode -- fCode )
    :M  HOPEN: { mode \ fnam1 pathname rc -- }
        path IF lock: path THEN
        heap> String -> fnam1  new: fnam1
        heap> String -> pathName new: pathName
        addr: filename count put: fnam1
        lock: fnam1
        start: fnam1 path
        IF  ascii : charOf: fnam1
            IF drop ^base mode (open)    \ assumed to be qualified path name
            ELSE
                limit: path 0
                DO i at: path put: pathname
                    pathname volname? 0=  hfs? land
                    IF    lock: pathname                                \ if not volume
                        get: pathname name: self unlock: pathname    \ get dirid
                        9 ^base +base dirfind drop
                        getdirid: self
                        get: fnam1 name: self
                        setdirid: self
                        ^base mode (open) -> rc    \ attempt to open
                        rc 0= IF leave THEN        \ found it !!
                    ELSE
                        pathName concat: fnam1
                        lock: pathname get: pathname ^base !fName unlock: pathname
                        ^base mode  (open)  -> rc
                        rc 0= IF leave THEN        \ found it !!
                    THEN
                LOOP
                rc IF get: fnam1 ^base !fName THEN
                rc    \ leave return code
            THEN
        ELSE
            hfs? 0=        \ strip HFS paths under MFS
            IF    ascii : charOf: fnam1
                IF    >R 0 -base                            \ setup for replace:
                    get: fnam1 MFSname drop ptr: fnam1 R + -
                    " :" drop R> 0> replace: fnam1        \ delete any path spec
                    get: fnam1 addr: filename >str255 drop
                THEN
            THEN
            ^base mode (open)
        THEN
        release: fnam1 dispose> fnam1
        release: pathname dispose> pathname
        path IF unlock: path THEN
    ;M

    \ ( -- fcode )  basic I/O operations
    :M  OPEN:
        ^base 22 + w@ ^base 48 + @ or
        IF ^base 0 (open)
        ELSE 0 Hopen: self THEN
    ;M

    :M  NEW:    ^base  (make)  ;M
    :M  DELETE: ^base (delete) ;M

    \ ( byteoffset -- fcode )  position relative to beginning-of-file
    :M  MOVETO: ^base 1 rot (lseek)   ;M

    \ ( -- byteoffset ) current position relative to beginning-of-file
    :M  WHERE: ^base 46 + @ ;M

    \ ( pos -- fcode )  set End-of-File to absolute byte position
    :M  SETEOF: ^base 28 + !  ^base $ a012 (fdos) ;M

    \ ( -- fcode )  open and reset file or create new if not present
    :M  CREATE: { \ volid -- fcode }
        ^base 22 + w@ -> volid
        open: self
        -dup
        IF    dup -43 =
            volid ^base 22 + w!
            IF    drop
                new: self -dup
                0= IF ^base 0 (open) THEN
            THEN
        ELSE
            0 setEOF: self
        THEN
    ;M

    \ ( -- #bytes )  return logical eof for file currently open
    :M  SIZE:  ^base $ a011 (fdos)  drop ^base 28 + @ ;M

    \ ( -- )  position to file's eof
    :M  LAST:  size: self moveTo: self drop  ;M

    \ ( -- lengthRead )  return actual bytes read
    :M  BYTESREAD:  ^base 40 + @ ;M

    \ ( -- fcbAddr )
    :M  FCB:  ^base  ;M

    \ ( -- fcode )
    :M  RESULT:  addr: fcb  16 + W@ ;M

    \ ( posMode -- )  Set position mode
    :M  MODE:  ^base 44 + W!   ;M

    \ ( addr length -- fcode )
    :M  READ: 0 mode: Self ^base swap rot (read)  ;M

    \ ( addr maxLen -- fcode )  Read terminating with CR
    :M  READLINE:  $ 0d80 Mode: self ^base swap rot (read)  ;M

    \ ( addr length -- fcode )
    :M  WRITE:  ^base  swap rot (write)  ;M

    \ ( n -- fcode )
    :M  PUT: pad c! pad 1 write: self ;M

    \ ( -- )  Set Fcb fields to 0
    :M  CLEAR:  ^base   clrFcb  ;M

    \ ( -- )  Get name from input stream, and assign to fcb
    :M  SETNAME:  ^base setName ;M

    \ ( -- addr len )  return filename
    :M  GETNAME:  addr: fileName count   ;M

    \ ( -- )  print the filename
    :M  PRINT:  getName: self  type    ;M

    \ ( ftype sig -- )  Set file type, signature
    :M  SET: { ftype sig -- }
         getdirid: self  ^base  ftype sig  file-install  setdirid: self ;M

    \ ( drive# -- )  set default drive to drive#
    :M  DRIVE:   Clear: self  setVRef: self  ^base $ a015 (fdos)
        ?error 165   ;M    \ Drive change unsuccessful

    \ ( addr len -- eof )  Simulate a Yerk expect from disk
    :M  EXPECT: { addr len -- }
        addr len 1+ erase  addr len ReadLine: self  0=
        IF  dEcho
            IF  addr bytesRead: self  1+ type cr
            THEN
            addr bytesread: self + 1-  0 swap c!  0
        ELSE  1 THEN   ;M

    \ ( -- eof )  Expect a line to the TIB
    :M  QUERY:  0 -> in  Tib 128 Expect: self 1 ++> line# ;M

    \ interpret the file as a Yerk source file
    \ ( -- )  name must first be set
    :M  INTERPRET: { \ icurs -- } -1 -> line#
        open: self  classErr" 132
        getName: self
        srcCreate            \ create file mark entry
        curs -> icurs -curs    \ Preserve cursor status
        BEGIN   nEvent
                query: self   0=
        WHILE  Interpret State   0= dEcho   And
            IF  ok  THEN
        REPEAT  ?exec close: self drop
        icurs -> curs -1 -> line#  ;M    \ Restore cursor status

     :M  FLUSHVOL: ^base $ A013 (fdos) drop ;M

    \ ( taddr tlen -- fcode )
    :M  RENAME: { taddr tlen -- result }
        taddr tlen str255
        ^base 28 + !  ^base $ A00B (fdos) ;M

    \ ( -- fcode )
    :M  OPENREADONLY:
        ^base 22 + w@ ^base 48 + @ or
        IF ^base 1 (open)
        ELSE 1 Hopen: self THEN ;M

    \ ( -- type )
    :M  GETTYPE:  ^base 32 + @ ;M

    \ ( -- fcode )  fills the parameter block with file info
    :M  GETFILEINFO:  ^base $ A20C (fdos)  ;M

    \ ( routine# -- bool )  call a Standard File Package routine
    :M  SFPCALL:  makeInt $ a9ea Trap
        get: good
        IF get: vRefNum ^base dup 80 erase set-file
            setVref: self  True
        ELSE  False
        THEN     ;M

    \ ( type0 ...typeN #types -- bool )  call SFGetFile
    :M  STDGET:  clear: fTypes  dup 0>
        IF 0 DO add: fTypes LOOP
        ELSE drop THEN
        $ 640064 0 0  size: fTypes -dup 0= IF -1 THEN makeInt
        ixAddr: fTypes +base 0 abs: good
        2 sfpCall: self  ;M

    \ call SFPutFile - takes promp, origName strings
    :M  STDPUT:  { pAddr pLen nAddr nLen -- bool }
        pLen pad c! pAddr pad 1+ pLen cmove
        $ 640064  pad +base  nAddr nLen str255 0 abs: good
        1 sfpCall: self  ;M

    :M  CLASSINIT:  clear: self  ;M

;CLASS

' File 'c fFcb !        \ set ffcb to member of file class

\ FileList keeps a stack of open load files for nested loads.
:CLASS FileList  <Super Ordered-Col

    \ release heap for the top element
    :M  REMOVE:  get: size dup 0= classerr" 137
        1- ^elem close: [ dup @ ] drop
        dispose  -1 +: size  ;M

    \ ( -- ^file ) add a new file to the stack
    :M  NEW:  heap> file  add: super   ;M

    \ interpret the top file
    :M  INTERPRET:  interpret: [ last: self ]  ;M

    \ ( -- )  remove all currently open files
    :M  CLEAR:  ." File stack: " cr \ type# 180 ( File stack: ) cr
        get: size 0
        DO print: [ last: self ] cr remove: self
        LOOP  ;M

    \ ( -- )  initialize list at startup
    :M  INIT:   clear: super  ;M

;CLASS

6 fileList loadFile

: lastLoad  last: loadFile ;
'c lastLoad vect topFile

\ ( addr len -- )  open named resource file
: orf { \ fnam1 pathname RC nfcb -- }
    new: loadFile name: topFile
    word0 getname: topfile str255 $ a997 trap i->l -1
     = IF
       HFS?  path land IF
        HEAP> String -> fnam1 new: fnam1
        heap> string -> pathName new: pathName
        getname: topfile put: fnam1 lock: fnam1
        -1 -> RC
        HEAP> file -> nfcb
        limit: path 0 DO
            i at: path put: pathname
            start: fnam1 get: fnam1 add: pathname
            lock: pathname get: pathname
            name: nfcb 9 nfcb +base dirfind
            0= IF nfcb 30 + c@ 16 and ELSE true Then  not
            IF
                word0 get: pathname STR255
                $ a997 trap i->l -> RC
                LEAVE
            THEN unlock: pathname
        LOOP
        Dispose> nfcb
        release: pathname dispose> pathname
        release: fnam1 dispose> fnam1
    ELSE   word0 getname: topfile STR255 $ a997 trap i->l -> rc
    THEN     RC -1 = abort" resource file open failed"
  THEN   remove: loadfile
;
\ ( addr len - )
:F OpenResFile ORF ;F

\ used to be defined in Event
\ ( val -- )  set text characteristics for current grafPort
: tfont  makeint $ a887 trap ;
: tFace  makeInt $ a888 trap ;
: tMode  makeInt $ a889 trap ;
: tSize  makeInt $ a88a trap ;

\ nesting loader. Use: // filename
: // { \ lcurs -- }
    curs -> lcurs -curs    \ Preserve cursor status
    new: loadFile  setName: topFile
    getName: topFile  3 tfont 1 tface type# 173 ( Loading: ) type 0 tface 4 tfont cr
    interpret: topFile  remove: loadFile
    lcurs -> curs ;        \ Restore cursor status

\ ================ Save ====================

'type COM  CONSTANT saveType            \ file type = 'COM '
\ use current application signature
: saveSig { \ myFile -- }
    heap> file -> myFile                \ need a file structure
    $ 910 -base count name: myFile        \ get nucleus name
    getFileInfo: myFile drop            \ get info
    myFile 36 + @ dispose> myFile ;        \ get signature

( -- Length of dictionary to be saved )
: flen      here Begin-dp @  - ;

Forward purge    \ defined in Ovl

0 Variable  H1 here 16 allot 16 erase

\ mark all windows closed
: togWindows { flag \ theWindow -- } 0 $ a924 trap
    BEGIN -base -> theWindow
          theWindow $ 90 + @                \ get next window in list
           flag theWindow 184 + w! ( markClosed: theWindow ) dup 0=    \ continue until no more windows
    UNTIL drop ;
: markWindowsClosed 0 togWindows ;
: markWindowsOpen   1 togWindows ;

\ Reuse target BIN file- so as not to wrestle file from it's folde
\ ( -- )  Save the user dictionary
: (Save) markWindowsClosed
    purge
    path 0 -> path    \ temporarily zero out path
    fFcb set-file
    create: fFcb ?error 107
    \ SAVE-HEAD
        here H1 !            \ Save DP
        fence H1 4+ !        \ Save FENCE
        voc-link H1 8+ !    \ Save VOC-LINK
        latest H1 12 + !    \ Save latest NFA
        0 mode: fFcb  0 fFcb 46 + w!
        H1 16 write: fFcb ?error 101
    \ WRITE-DICT
        $ 10 fFcb $ 2E + W!
        begin-dp @ flen write: fFcb ?error 105
    saveType saveSig set: fFcb
    close: fFcb drop
    -> path            \ restore path
    markWindowsOpen ;

\ Save command takes name from input stream
: Save
    setName: fFcb (save) ;

\ when // executes, it adds a new file object on the heap to a
\ stack of files. This permits embedded loads, providing hierarchical
\ nesting of source files.

: cleanUp  [Compile] ;class  clear: loadFile  init8  parmlist -1 -> line# ;
: filinit   ' File 'c fFcb !  init: loadFile ;

'c filinit -> objinit
'c cleanUp -> abortvec

'type TEXT constant txType

\ true -> docs

// tool.load